Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/C/Applications/Moscow ML 1.42/src/mosmllib/TextIO.sml

Text File | 1997-08-18 | 10.4 KB | 313 lines | [TEXT/R*ch]

(* TextIO -- 1995-11-22, 1996-07-07; no positions etc. yet *)

type elem = Char.char
type vector = string
type pos = int

prim_val create_string_ : int -> string                 = 1 "create_string";
prim_val nth_char_      : string -> int -> char         = 2 "get_nth_char";
prim_val set_nth_char_  : string -> int -> char -> unit = 3 "set_nth_char";
prim_val blit_string_   : string -> int -> string -> int -> int -> unit
                                                        = 5 "blit_string";

fun sub_string_ s start len =
  let val res = create_string_ len
  in blit_string_ s start res 0 len; res end
;

(* Caml Light "channels" *)

prim_type in_channel and out_channel;

prim_val open_descriptor_in : int -> in_channel = 1 "open_descriptor";
        (* [open_descriptor_in fd] returns a buffered input channel
           reading from the file descriptor [fd]. The file descriptor [fd]
           must have been previously opened for reading, else the behavior is
       undefined. *)

prim_val open_descriptor_out : int -> out_channel = 1 "open_descriptor";
        (* [open_descriptor_out fd] returns a buffered output channel
           writing to the file descriptor [fd]. The file descriptor [fd]
           must have been previously opened for writing, else the behavior is
       undefined. *)

prim_val input_char_ : in_channel -> char = 1 "input_char"
        (* Read one character from the given input channel.
           Raise [Size] if there are no more characters to read. *)

prim_val output_char_ : out_channel -> char -> unit = 2 "output_char";

prim_val caml_seek_in : in_channel -> int -> unit = 2 "seek_in"
        (* [seek_in chan pos] sets the current reading position to [pos]
           for channel [chan]. *)

prim_val caml_pos_in : in_channel -> int = 1 "pos_in";
        (* Return the current reading position for the given channel. *)

prim_val caml_close_in : in_channel -> unit = 1 "close_in"
        (* Close the given channel. Anything can happen if any of the
           above functions is called on a closed channel. *)

type file_perm = int;

datatype open_flag =
    O_RDONLY                       (* `open' read-only *)
  | O_WRONLY                       (* `open' write-only *)
  | O_RDWR                         (* `open' for reading and writing *)
  | O_APPEND                       (* `open' for appending *)
  | O_CREAT                        (* create the file if nonexistent *)
  | O_TRUNC                        (* truncate the file to 0 if it exists *)
  | O_EXCL                         (* fails if the file exists *)
  | O_BINARY                       (* `open' in binary mode *)
  | O_TEXT                         (* `open' in text mode *)
;

prim_val sys_open :
  string -> open_flag list -> file_perm -> int = 3 "sys_open"
        (* Open a file. The second argument is the opening mode.
           The third argument is the permissions to use if the file
           must be created. The result is a file descriptor opened on the
           file. *)
prim_val sys_close :
  int -> unit = 1 "sys_close"
        (* Close a file descriptor. *)

val caml_std_in  = open_descriptor_in 0
and caml_std_out = open_descriptor_out 1
and caml_std_err = open_descriptor_out 2
;

prim_val fast_input :
  in_channel -> string -> int -> int -> int = 4 "input";
prim_val fast_output :
  out_channel -> string -> int -> int -> unit = 4 "output";

fun caml_open_in_gen mode rights filename =
  open_descriptor_in (sys_open filename mode rights)
;

val caml_open_in = caml_open_in_gen [O_RDONLY, O_TEXT] 0
and caml_open_in_bin = caml_open_in_gen [O_RDONLY, O_BINARY] 0
;

fun open_out_gen mode rights filename =
  open_descriptor_out(sys_open filename mode rights)
;

prim_val s_irall : file_perm = 0 "s_irall";
prim_val s_iwall : file_perm = 0 "s_iwall";

val caml_open_out =
  open_out_gen [O_WRONLY, O_TRUNC, O_CREAT, O_TEXT] (s_irall + s_iwall)
and caml_open_out_bin =
  open_out_gen [O_WRONLY, O_TRUNC, O_CREAT, O_BINARY] (s_irall + s_iwall)
;

prim_val caml_flush : out_channel -> unit = 1 "flush"
        (* Flush the buffer associated with the given output channel,
           performing all pending writes on that channel.
           Interactive programs must be careful about flushing [std_out]
           at the right times. *)

fun caml_output_string channel s =
    fast_output channel s 0 (size s);

prim_val caml_close_out : out_channel -> unit = 1 "close_out"
        (* Close the given channel, flushing all buffered write operations.
       The behavior is unspecified if any of the above functions is
       called on a closed channel. *)

fun try_input_char_ ic =
  SOME (input_char_ ic)
  handle Size => NONE;

(* Moscow ML imperative Text I/O *)

type instream  = { closed: bool, ic: in_channel,  name : string} ref;
type outstream = { closed: bool, oc: out_channel, name : string} ref;

val stdIn  : instream  =
    ref { closed=false, ic=caml_std_in,  name = "<stdIn>"  }
and stdOut : outstream =
    ref { closed=false, oc=caml_std_out, name = "<stdOut>" }
and stdErr : outstream =
    ref { closed=false, oc=caml_std_err, name = "<stdErr>" };

fun raiseIo fcn nam exn =
    raise Io {function = fcn, name = nam, cause = exn};

fun raiseClosed fcn nam =
    raiseIo fcn nam (Fail "Stream is closed");

fun openIn s =
  ref {closed=false, ic=caml_open_in s, name = s}
  handle exn as SysErr _ => raiseIo "openIn" s exn;

fun closeIn (is as ref {closed, ic, name}) =
  if closed then ()
  else (caml_close_in ic;
    is := { closed=true, ic=ic, name=name });

fun input1 (is as ref {closed, ic, name}) =
    if closed then NONE
    else
    SOME (input_char_ ic)
    handle Size => NONE;

fun input (is as ref {closed, ic, name}) =
    if closed then ""
    else let val buff = create_string_ 60
     in case fast_input ic buff 0 60 of
         0 => ""
       | m => sub_string_ buff 0 m
     end;

fun inputN (is as ref {closed, ic, name}, n) =
    if n < 0 orelse n > String.maxSize then raise Size
    else if closed then ""
    else let val buff = create_string_ n
         fun loop k =
         if k = n then buff
         else
             case fast_input ic buff k (n-k) of
             0 => sub_string_ buff 0 k
               | m => loop (k+m)
     in loop 0 end;

fun inputAll (is as ref {closed, ic, name}) =
  if closed then "" else
  let val max = ref 127
      val tmp = ref (create_string_ (!max))
      fun realloc () =
      let val newmax = if !max = String.maxSize then raise Size
               else if 2 * !max >= String.maxSize then String.maxSize
               else 2 * !max
          val newtmp = create_string_ newmax
      in
          blit_string_ (!tmp) 0 newtmp 0 (!max);
          max := newmax;
          tmp := newtmp
      end
      (* Don't read more than runtime/io.IO_BUFFER_SIZE characters:  *)
      fun chunksize sz = if sz > 4096 then 4096 else sz
      fun h len =
      case fast_input ic (!tmp) len (chunksize (!max - len)) of
          0 => sub_string_ (!tmp) 0 len
        | m => (if !max - (len + m) < 127 then realloc () else ();
            h (len + m));
  in h 0 end;

type cs = int (* character source state *)

fun scanStream scan  (instrm as ref {closed, ic, name}) =
    let prim_eqtype array_
    prim_val array_  : int -> array_                 = 1 "create_string";
    prim_val sub_    : array_ -> int -> char         = 2 "get_nth_char";
    prim_val update_ : array_ -> int -> char -> unit = 3 "set_nth_char";

        val buf  = array_ 512        (* characters recently read     *)
    val read = ref 0        (* number of characters read    *)
    fun getc charno =
        if charno < !read then        (* already read         *)
        if charno >= !read - 512 then    (* still in buffer      *)
            SOME(sub_ buf (charno mod 512), charno+1)
        else                (* no longer in buffer  *)
            raise Fail "scanStream: backtracking too far"
        else            (* charno = !read; read a new character *)
        if closed then NONE
        else (let val c = input_char_ ic
              in (update_ buf (charno mod 512) c;
              read := !read + 1;
              SOME(c, charno+1))
              end handle Size => NONE)
    in case scan getc 0 of
        NONE         => NONE
      | SOME(res, _) => SOME res
    end;

fun inputNoBlock (is : instream) : vector option =
    raise Fail "not implemented";

fun lookahead (is as ref {closed, ic, name}) =
  if closed then NONE else
  let val pos = caml_pos_in ic in
      case try_input_char_ ic of
      NONE            => NONE
    | res as (SOME c) => (caml_seek_in ic pos; res)
  end;

fun endOfStream is = (lookahead is = NONE);

fun openAppend (s : string) : outstream =
  ref { closed=false,
        oc=open_out_gen [O_WRONLY, O_APPEND, O_CREAT, O_TEXT]
                        (s_irall + s_iwall) s,
    name=s}
  handle exn as SysErr _ => raiseIo "openAppend" s exn;

fun output (os as ref {closed, oc, name}, s) =
    if closed then
    raiseClosed "output" name
    else
    (caml_output_string oc s;
     if os = stdErr then caml_flush oc else ());

fun outputSubstr (os as ref {closed, oc, name}, sus : substring) =
    let prim_val substrToTrip : substring -> string * int * int = 1 "identity"
        val (s, i, n) = substrToTrip sus
    in if closed then
      raiseClosed "outputSubstr" name
       else
       (fast_output oc s i n;
        if os = stdErr then caml_flush oc else ())
    end;

fun output1 (os as ref {closed, oc, name}, c) =
    if closed then
    raiseClosed "output1" name
    else
    (output_char_ oc c;
     if os = stdErr then caml_flush oc else ());

fun inputLine (is as ref {closed, ic, name}) =
  if closed then "" else
  let val max = ref 127
      val tmp = ref (create_string_ (!max))
      fun realloc () =
      let val newmax = if !max = String.maxSize then raise Size
               else if 2 * !max >= String.maxSize then String.maxSize
               else 2 * !max
          val newtmp = create_string_ newmax
      in
          blit_string_ (!tmp) 0 newtmp 0 (!max);
          max := newmax;
          tmp := newtmp
      end
      fun h len =
      (if len >= !max then realloc () else ();
       case try_input_char_ ic of
           NONE   => (set_nth_char_ (!tmp) len #"\n";
              sub_string_ (!tmp) 0 (len+1))
         | SOME c => (set_nth_char_ (!tmp) len c;
              if c = #"\n" then sub_string_ (!tmp) 0 (len+1)
                           else h (len+1)))
  in if endOfStream is then "" else h 0 end;

fun openOut (s : string) : outstream =
    ref {closed=false, oc=caml_open_out s, name=s}
    handle exn as SysErr _ => raiseIo "openOut" s exn;

fun closeOut (os as ref {closed, oc, name}) =
    if closed then ()
    else (caml_close_out oc;
      os := {closed = true, oc=oc, name=name};
      ());

fun flushOut (os as ref {closed, oc, name}) =
  if closed then
      raiseClosed "flushOut" name
  else
      caml_flush oc;

fun print s = (output(stdOut, s); flushOut stdOut);